;;;; -*- Mode: LISP; Package: cl-user -*-

(in-package :cl-user)

;;;;
;;;; observer.lisp
;;;;


(defun nsstr (s) (ccl::%make-nsstring s))
(defun lisp-string (ns) (%get-cstring (#/UTF8String ns)))

;;; A simple w

(defclass observer (ns:ns-object)
  ((lobj :accessor lisp-object :initarg :object)
   (ignore-slots :accessor ignore-slots :initarg :ignore-slots :initform nil))
  (:metaclass ns:+ns-object))

(defun make-observer (object &optional (ignore-slots nil))
  (make-instance 'observer :object object :ignore-slots ignore-slots))

(defgeneric has-children-p (observer lisp-object)
  (:documentation "Lisp types that wish to be treated as tree objects
by a TreeController need to specialize this method and return #$YES"))

(defgeneric list-children (observer lisp-object)
  (:documentation ""))

(defgeneric children-count (observer lisp-object))
  
(defmethod has-children-p (self lisp-object)
  (declare (ignore self lisp-object))
  #$NO)

;; This seems to work, but I wonder what unintended
;; consequences I court by not making copies of the
;; lisp object pointed to by the inspector object...
(objc:defmethod (#/copyWithZone: :id) ((self observer) zone)
  (declare (ignore zone))
  (make-instance 'observer :lisp-object (lisp-object self)
		 :ignore-slots (ignore-slots self)))

(objc:defmethod (#/isLeaf #>BOOL) ((self observer))
  (has-children-p self (lisp-object self)))

(objc:defmethod (#/children :id) ((self observer))
  (list-children self (lisp-object self)))

(defun lisp->kvc-compliant (value)
  "Given a Lisp value return its FoundationKit equivalent type (e.g. for number types return an NSNumber, lists return NSArrays, symbols and strings return NSStrings."
  (typecase value
    (double-float (#/numberWithDouble: ns:ns-number value))
    (float (#/numberWithFloat: ns:ns-number value))
    (bignum (#/numberWithLongLong: ns:ns-number value))
    (fixnum (#/numberWithInt: ns:ns-number value))
    (string (nsstr value))
    (character (nsstr (string value)))
    (symbol (nsstr (symbol-name value)))
    (list (let ((ret-array (make-instance 'ns:ns-mutable-array)))
	    (dolist (item value ret-array)
	      (format t "~A~%" (type-of item))
	      (#/addObject: ret-array (lisp->kvc-compliant item)))))
    (t (make-instance 'observer :object value))))

;;; Here we specify the type since NSString's are overloaded
;;; to represent symbols, characters, and strings.
;;; It makes working with NSNumber's every so slightly easier, too.

(defun kvc-compliant->lisp (value type)
  (case type
    ((:double double-float) (#/doubleValue value))
    (:float (#/floatValue value))
    (:int (#/intValue value))
    (:string (lisp-string value))
    (:symbol (intern (lisp-string value)))
    (t value)))


;;; Check the end of this file for examples on how to use these macros.
(defmacro atomic-kvc-accessor (name accessor-fn type)
  "Generates key-value access and setting objc methods for a lisp object wrapped by observer.  Used when the key returns a value that can be passed directly to lisp->kvc-compliant."
  (let ((set-key (intern (concatenate 'string "set"
				      (string-upcase (char (symbol-name name) 0))
				      (string-downcase (subseq (symbol-name name) 1))
				      ":")
			 "NEXTSTEP-FUNCTIONS")))
    (aux:with-unique-names (robj sobj nval)
      `(progn
	 (objc:defmethod (,(intern (symbol-name name) "NEXTSTEP-FUNCTIONS") :id) ((,robj observer))
	   (lisp->kvc-compliant (,accessor-fn (lisp-object ,robj))))
	 (objc:defmethod (,set-key :void) ((,sobj observer) ,nval)
	   (setf (,accessor-fn (lisp-object ,sobj)) (kvc-compliant->lisp ,nval ,type)))))))

(defmacro composite-kvc-accessor (name accessor-fn)
  "Generates key-value access and setting objc methods for a lips object wrapped by an observer.  Used when the key returns a object, like a struct or a clos object, that should not be processed by lisp->kvc-compliant."
  (aux:with-unique-names (obj prop)
    `(objc:defmethod (,(intern (symbol-name name) "NEXTSTEP-FUNCTIONS") :id) ((,obj observer))
       (let ((,prop (,accessor-fn (lisp-object ,obj))))
	 (typecase ,prop
	   (list (lisp->kvc-compliant ,prop))
	   (t (make-instance 'observer :object (,accessor-fn (lisp-object ,obj)))))))))

(defmacro kvc-key (name)
  (let ((key-name-fn (intern (concatenate 'string "is" 
					  (string-upcase (char (symbol-name name) 0))
					  (string-downcase (subseq (symbol-name name) 1)))
			     "NEXTSTEP-FUNCTIONS")))
    `(objc:defmethod (,key-name-fn #>BOOL) ((ignore observer))
       (declare (ignore ignore))
       #$YES)))

;;;; A class for observing class slots

(defclass class-slot-observer (observer)
  ((sname :accessor slot-name :initarg :slot-name)
   (writer-fn :accessor writer-fn)
   (reader-fn :accessor reader-fn)
   (value :accessor value :initarg :value :foreign-type :id))
  (:metaclass ns:+ns-object))

(defun determine-accessors (place)
  (multiple-value-bind (vars vals store-vars writer reader)
      (get-setf-expansion place)
    (let ((getter-fn  (compile nil `(lambda (,(car vals))
                                      (let ((,(car vars) ,(car vals)))
                                        ,reader))))
          (setter-fn nil))
      (catch 'setter-not-defined
        (handler-bind ((condition #'(lambda (c)
                                      (declare (ignore c))
                                      (setf setter-fn 'bogus-fn)
                                      (throw 'setter-not-defined nil))))
          (setq setter-fn (compile nil `(lambda (,(car store-vars) ,(car vals))
                                          (let ((,(car vars) ,(car vals)))
                                            ,writer))))))
      (values
       setter-fn
       getter-fn))))

(defmethod initialize-instance :after ((cso class-slot-observer) &rest initargs)
  (declare (ignore initargs))
  (with-slots (lobj sname value reader-fn writer-fn) cso
    (multiple-value-bind (writer reader) (determine-accessors `(,sname lobj)) 
      (setf writer-fn writer
	    reader-fn reader)
      (#/willChangeValueForKey: cso #@"value")
      (setf value (lisp->kvc-compliant (funcall reader-fn lobj)))
      (#/didChangeValueForKey: cso #@"value")
      ;; Now register as an observer (that term's getting a bit overloaded, no?))
      (catch 'setter-not-defined
        (handler-bind ((ccl::undefined-function #'(lambda (c)
						    (declare (ignore c))
						    ;; Set some editable property
						    (setf writer-fn nil)
						    (throw 'setter-not-defined nil))))
          (funcall writer-fn (funcall reader-fn lobj) lobj))
        (#/addObserver:forKeyPath:options:context: cso
                                                   cso
                                                   #@"value"
                                                   0
                                                   +null-ptr+)))))

(objc:defmethod (#/observeValueForKeyPath:ofObject:change:context: :void)
    ((self class-slot-observer) path object change context)
  (declare (ignore change context))
  (format t "Observing change for path ~A~%" (lisp-string path))
  (if (and (string= (lisp-string path) "value") (writer-fn object))
      (with-slots (sname lobj value reader-fn writer-fn) object
	(funcall writer-fn
		 (kvc-compliant->lisp value 
				      (type-of (funcall reader-fn lobj)))
		 lobj))))

(objc:defmethod (#/name :id) ((self class-slot-observer))
  (lisp->kvc-compliant (slot-name self)))

(defun make-class-slot-observer (object slot-name)
  (make-instance 'class-slot-observer :object object
		 :slot-name slot-name))

;;; Implementing tree behavior for Observers

(defmethod has-children-p ((self class-slot-observer) object)
  (let ((test-obj (funcall (reader-fn self) object)))
    (if (or (subtypep (class-of test-obj) 'standard-object)
	    (listp test-obj)
	    (arrayp test-obj))
	#$YES
	#$NO)))

(defmethod has-children-p ((self observer) (object standard-object))
  #$YES)

(defmethod list-children ((self observer) (object standard-object))
  (let ((slots (compute-slots (class-of (lisp-object self))))
	(sarray (#/array ns:ns-mutable-array)))
    (dolist (s slots sarray)
      (let ((name (slot-value s 'ccl::name)))
	(unless (find name (ignore-slots self))
	  (#/addObject: sarray (make-class-slot-observer object name)))))))

(defmethod children-count (self (object standard-object))
  (length (compute-slots (class-of (lisp-object self)))))

;; Move this to tests!
(defun test-cso ()
  (let* ((obj (cp:cpv 2 2))
         (body (cp:new-body 5.0 5.0))
	 (cso (make-class-slot-observer obj 'cp:cpv.x))
         (bcso-mass (make-class-slot-observer body 'cp:mass))
         (bcso-moment (make-class-slot-observer body 'cp:moment))
	 (ob-body (make-observer body '(cp::ptr))))
    (format t "---- Chipmunk Vectors ----~%")
    (format t "Slot (lisp): ~A~%" (slot-name cso))
    (format t "Slot (kvc): ~A~%" (#/valueForKey: cso #@"name"))
    (format t "Value (lisp): ~A~%" (value cso))
    (format t "Value (kvc): ~A~%" (#/valueForKey: cso #@"value"))
    (#/setValue:forKey: cso (lisp->kvc-compliant 3.0d0) #@"value")
    (format t "Value (kvc): ~A~%" (#/valueForKey: cso #@"value"))
    (format t "Value (object): ~A~%" (cp:cpv.x obj))
    (format t "---- Chipmunk Bodies ----~%")
    (format t "~A: ~A    ~A: ~A~%" (lisp-string (#/valueForKey: bcso-mass #@"name"))
            (#/valueForKey: bcso-mass #@"value")
            (lisp-string (#/valueForKey: bcso-moment #@"name"))
            (#/valueForKey: bcso-moment #@"value"))
    (format t "Children of ~A:  ~A~%" body (#/children ob-body))))


;;; --------
;;; Some kvc accessors for data types defined in
;;; the Chipmunk 2D physics library.

;; -- cpObjects --
(atomic-kvc-accessor |name| cp:name :symbol)

;; -- Spaces --
(composite-kvc-accessor |gravity| cp:gravity)
(atomic-kvc-accessor |bodies| cp:bodies :list)
(atomic-kvc-accessor |shapes| cp:shapes :list)
(atomic-kvc-accessor |joints| cp:joints :list)

;; -- Vectors --
(atomic-kvc-accessor |x| cp:cpv.x :double)
(atomic-kvc-accessor |y| cp:cpv.y :double)

;; -- Bodies --
(atomic-kvc-accessor |mass| cp:mass :double)
(atomic-kvc-accessor |moment| cp:moment :double)
(composite-kvc-accessor |pos| cp:pos)

;; -- Shapes --
(composite-kvc-accessor |body| cp:body)
(atomic-kvc-accessor |elasticity| cp:elasticity :double)
(atomic-kvc-accessor |friction| cp:friction :double)
(atomic-kvc-accessor |friction| cp:collision-type :int)

;; -- Circle --
(atomic-kvc-accessor |radius| cp:radius :double)
(composite-kvc-accessor |center| cp:center)

;; -- Segment --
(atomic-kvc-accessor |thickness| cp:thickness :double)
(composite-kvc-accessor |startPoint| cp:start-point)
(composite-kvc-accessor |endPoint| cp:end-point)


;;;; ---- **** ----
;;; Routines for testing/debugging.  At the moment not appropriate
;;; for automated testing (like that provided in stefil and similar)
;;; since testing depends on the review of each functions output from
;;; a human eye.

(defun test-kvc-types ()
  (format t "~A~%" (lisp->kvc-compliant 2))
  (format t "~A~%" (lisp->kvc-compliant 1))
  (format t "~A~%" (lisp->kvc-compliant 102938))
  (format t "~A~%" (lisp->kvc-compliant 2.0))
  (format t "~A~%" (lisp->kvc-compliant 2.0d0))
  (format t "~A~%" (lisp->kvc-compliant "I am KVC compliant!"))
  (format t "~A~%" (lisp->kvc-compliant #\A))
  (format t "~A~%" (lisp->kvc-compliant 'lisp-symbol))
  (format t "~A~%" (lisp->kvc-compliant '(a b c d e)))
  (format t "~A~%" (lisp->kvc-compliant (list 'a 'b 'c (list 'd 'e)))))

(defun test-cp-bindings ()
  (let* ((vec (make-instance 'observer
                :object (cp:cpv 2 4)))
         (circle (make-instance 'observer
                   :object (make-instance 'cp:circle-shape
                             :body (make-instance 'cp:body
                                     :mass 1.0 :moment 1.0
                                     :position (cp:cpv 101 10))
                             :radius 5.0
                             :offset cp:+cpvzero+)))
         (bod (make-instance 'observer
                :object (make-instance 'cp:body
                          :mass 1.0
                          :moment 1.0
                          :position (cp:cpv 1 1))))
         (space (make-instance 'observer
                  :object (cp::create-test-space))))
    (format t "Vector (~A, ~A)~%" (#/x vec) (#/valueForKey: vec #@"y"))
    (format t "Position of ~A = (~A, ~A)~%" bod (#/doubleValue (#/valueForKeyPath: bod #@"pos.x"))
	    (#/valueForKeyPath: bod #@"pos.y"))
    (format t "Position check = (~A, ~A)~%" (cp:cpv.x (cp:pos (lisp-object bod))) (cp:cpv.y (cp:pos (lisp-object bod))))
    (#/setValue:forKeyPath: bod (#/numberWithDouble: ns:ns-number 25.0d0) #@"pos.x")
    (format t "Circle ~A at (~A, ~A) with radius ~A and center ~A.~%"
            (#/valueForKey: circle #@"name")
            (#/valueForKeyPath: circle #@"body.pos.x")
            (#/valueForKeyPath: circle #@"body.pos.y")
            (#/valueForKey: circle #@"radius")
	    (lisp-object (#/valueForKey: circle #@"center")))
            ;(#/valueForKey: circle #@"center.x")
            ;(#/valueForKey: circle #@"center.y"))
    (format t "Shapes: ~A~%Bodies: ~A~%" 
	    (#/valueForKey: space #@"shapes") (#/valueForKey: space #@"bodies"))))
